Macwelt 1/Macwelt DVD 1.toast/Web-Publishing/HTML-Editoren/Alpha ƒ/Tcl/Modes/fortranMode.tcl

Text File | 2000-12-07 | 21.1 KB | 672 lines

#=============================================================================
# Fortran mode definition and support procs
#
# Features:
# 1.  Keyword colorization (slightly customizable)
# 2.  Fortran-sensitive shift right/left preserve columns 1-6
# 3.  Auto-indentation
# 4.  Line-breaking with Ctl-Opt-J (a la emacs)
# 5.  Subroutine indexing
# 6.  Cmd-double-click subroutine and include-file lookup
# 7.  Customizable comment and continuation characters
#
#------------------------------------------------------------------------------
# Author: Tom Pollard <[e-mail]>
#
# To Do:  work around grep failure for Unix-format tag files
#
#  8/97 - Updated for new system code.
#  4/97 - Coloring bug fixed.
#  1/96 - Fort::MarkFile no longer marks F90 "end subroutine ..." statements
#         more F90 keywords (will they never cease?)
#  1/96 - user-selectable comment and continuation characters
#         complete F90 keyword set (Thomas Bewley <[e-mail]>)
#         F90 functions and comparison operators optionally colorized ( " " )
#         more complete set of C preprocessor commands colorized
#         fixed case-sensitivity problem in line-indent routines
#  1/96 - minor Fort::DblClick bug fix
# 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
# 12/95 - cpp keyword colorization (George Nurser <[e-mail]>)
#         cmd-dbl-click supports cpp #include now
# 11/95 - added FortBreakLine
#         fixed case-sensitivity bug
# 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
#            improve performance (fortFindSub)
#  9/95 - fixed getFortPrev bug with numbered lines
#       - shiftLeft/Right revert to normal behavior on ill-formatted lines
#  8/95 - auto-indentation is finally speedy and robust
#  5/95 - added Cmd-Dbl-Click handler
#       - added auto-indentation
# 12/94 - fixed funcExpr, Fort::MarkFile search expressions
#       - changed comment character from 'C' to 'c' (should be case-insensitive!)
#       - added 'include' keyword
#       - added FortShiftRight and FortShiftLeft procs
#------------------------------------------------------------------------------


#================================================================================
alpha::mode Fort 1.0.2 dummyFort \
  {*.f *.inc *.INC *.fcm *.for *.FOR *.f9 *.f90 *.hpf } {electricTab} {
    set unixMode(fortran) {Fort}
} help {
    Fortran Mode provides keyword coloring, subrouting marking and
    indexing, Fortran sensitive shifting of blocks of code preservering
    columns 1-6, automatic code indentation.  Line breaks are inserted
    with ctrl-opt-J. Supports cmd-dbl-click for jumping to subroutines
    and opening of include files.  Comment characters can be set in
    Preferences (F12).

    Click on this "FORTRAN Example.f" link for an example syntax file.
}

proc dummyFort {} {}

newPref f sortedIsDefault    {0} Fort
newPref f wordWrap        {0} Fort
newPref v funcExpr    {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} Fort
newPref f autoMark        {0} Fort

newPref    v continueChar    {$} Fort
newPref    v commentChar    {c} Fort shadowFort
newPref    f colorFuncs    {0} Fort shadowFort
newPref    f colorOpers    {0} Fort shadowFort

newPref f indentComment    {0} Fort
newPref v markTag        {{}} Fort

#=============================================================================
# Colorize Fortran keywords
#
proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
    global FortmodeVars

    set FortKeywords {
    allocatable allocate assign backspace block call character close common
    complex contains continue cycle data deallocate dimension do double else
    elseif end enddo endfile endif entry equivalence exit external extrinsic
    forall format function goto if implicit include inquire integer intent
    interface intrinsic logical module namelist nullify open optional
    parameter pause pointer precision print private program public pure read
    real recursive return rewind save sequence stop subroutine target then
    use where while write assignment case default elsewhere endfile go none
    operator procedure select to type
    }

    if {$specialChars != "black"} {
    regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  -i {=}  -i {*}  -i {/}  -i {+}  -i {-}  -i {,}  -i {(} -i {)} -I $specialChars
    } else {
    regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords
    }
    unset FortKeywords
}

#=============================================================================
# Colorize selected C preprocessor keywords
#
proc fortColorCPP {{color green}} {
    set CPPKeywords  {
    #if #endif #include #else #define #undef #ifdef #ifndef
    }
    regModeKeywords -a  -k $color Fort $CPPKeywords
    unset CPPKeywords
}


#=========================================================================
# Colorize Fortran operators
#
proc fortColorOpers {{color green}} {
    set FortOperators {
    eq ne lt le gt ge not and or eqv neqv true false
    }
    regModeKeywords -a -k $color Fort $FortOperators
    unset FortOperators
}

#=========================================================================
# Colorize Fortran function keywords
#
proc fortColorFuncs {{color green}} {
    # Fortran bit functions
    #
    set BitKeywords {
    bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
    }
    regModeKeywords -a -k $color Fort $BitKeywords
    unset BitKeywords

    # Fortran intrinsic functions
    #
    set IntrinsicKeywords {
    abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar
    len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh
    iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim
    ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1
    amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl
    isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx
    index int nint achar adjustl adjustr all allocated any associated
    bit_size btest ceiling count cshift date_and_time digits dot_product
    eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits
    ibset ieor ior ishft ishftc kind lbound len_trim logical matmul
    maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits
    nearest not pack precision present product radix random_number
    random_seed range repeat reshape rrspacing scale scan selected_int_kind
    selected_real_kind set_exponent shape size spacing spread sum
    system_clock tiny transfer transpose trim ubound unpack verify
    }
    regModeKeywords -a -k $color Fort $IntrinsicKeywords
    unset IntrinsicKeywords
}

fortColorKeywords blue red magenta
fortColorCPP green
if {$FortmodeVars(colorFuncs)} {
    fortColorFuncs green
}
if {$FortmodeVars(colorOpers)} {
    fortColorOpers green
}
#=============================================================================
# Special Fortran keybindings
#
Bind '\[' <c>  FortShiftLeft Fort
Bind '\[' <co> FortShiftLeftSpace Fort
Bind '\]' <c>  FortShiftRight Fort
Bind '\]' <co> FortShiftRightSpace Fort

Bind 'j'  <zo> FortBreakLine Fort

#=============================================================================
# Update colorization when Fortran mode variables are changed
#
proc shadowFort {name2} {
    global HOME FortmodeVars
    switch -- $name2 {
    "colorFuncs"    {
        if {$FortmodeVars(colorFuncs)} {
        fortColorFuncs green
        } else {
        fortColorFuncs black
        }
    }
    "colorOpers"    {
        if {$FortmodeVars(colorOpers)} {
        fortColorOpers green
        } else {
        fortColorOpers black
        }
    }
    "commentChar" {
        fortColorKeywords blue red magenta
    }
    default {
        return
    }
    }
}

#=============================================================================
#
proc Fort::MarkFile {} {
    global FortmodeVars
    set tag [quote::Regfind $FortmodeVars(markTag)]

    set pat0 {^.*(subroutine|.*function|entry|program).*$}
    set pat1 {^[^cC*!]([ \ta-z*0-9]*)(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
    set end [maxPos]
    set pos [minPos]
    while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
    regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
    set start [lineStart [lindex $mtch 0]]
    set next [nextLineStart $start]
    set pos $next
    if {! [regexp -nocase "end" $valtyp mtch]} {
        set inds([lineStart $start]) $name
    }

    }

    set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
    set pos [minPos]
    while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
    regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
    regsub -all {[\/\(\)]} $comment {} comment
    set start [lindex $mtch 0]
    set end [nextLineStart $start]
    set pos $end
    set inds([lineStart $start]) $comment
    }

    if {[info exists inds]} {
    foreach f [lsort -integer [array names inds]] {
        set next [nextLineStart $f ]
        setNamedMark $inds($f) $f $f $f
    }
    }
}

#================================================================================
# Block shift left and right for Fortran mode (preserves cols 1-6)
#================================================================================

proc FortShiftLeft {} {
    global shiftChar
    doFortShiftLeft "\t"

}
proc FortShiftLeftSpace {} {
    global shiftChar
    doFortShiftLeft " "
}

proc doFortShiftLeft {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [pos::math [selEnd] - 1]]
    if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}

    set text [split [getText $start [pos::math $end - 1]] "\r"]

    set textout ""

    set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
    if {[regexp $pat $line mtch pref body]} {
        if {[string index $body 0] == $shiftChar} {
        lappend textout $pref[string range $body 1 end]
        } else {
        lappend textout $line
        }

    } elseif {[string index $line 0] == $shiftChar} {
        lappend textout [string range $line 1 end]

    } else {
        lappend textout $line
    }
    }

    set text [join $textout "\r"]
    replaceText $start [pos::math $end - 1] $text
    select $start [pos::math $start + 1 + [string length $text]]
}

proc FortShiftRight {} {
    global shiftChar
    doFortShiftRight "\t"

}
proc FortShiftRightSpace {} {
    global shiftChar
    doFortShiftRight " "
}

proc doFortShiftRight {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [pos::math [selEnd] - 1]]
    if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}

    set text [split [getText $start [pos::math $end - 1]] "\r"]

    set textout ""

    set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
        if {[regexp $pat $line mtch pref body]} {
            lappend textout $pref$shiftChar$body
        } else {
            lappend textout $shiftChar$line
        }
    }

    set text [join $textout "\r"]
    replaceText $start [pos::math $end - 1] $text
    select $start [pos::math $start + 1 + [string length $text]]
}

proc FortBreakLine {} {
    global FortmodeVars
    set pos [getPos]
    set line [getText [lineStart $pos] [pos::math [nextLineStart $pos] - 1]]
    if {[regexp {^[cC*!]} $line char]} {
    insertText "\n$char "
    } else {
    set char $FortmodeVars(continueChar)
    insertText "\n     $char"
    }
    FortindentLine
}

#=============================================================================
# Cmd-double-clicking opens include files, jumps to subroutine definitions,
# and follows tags.
#
proc Fort::DblClick {from to} {
    global tagFile
    set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
    set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}

    # First check whether an 'include' was clicked
    set line [getText [lineStart $from] [pos::math [nextLineStart $to] - 1]]
    if {[regexp -nocase $incPat $line allofit fname]} {
    set path [absolutePath $fname]
    if {[catch {file::openQuietly $path}]} {
        message "include file \'$fname\' not found in source folder"
    }
    return
    }

    select $from $to
    set text [getSelect]

    # First check current file for subroutine definition,...
    if {![catch {fortFindSub $text} mtch]} {
    regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
    placeBookmark
    display [lindex $mtch 0]
    #         eval select $mtch
    message "press <Ctl .> to return to original cursor position"

    # ...then check tags file.
    } else {
    message "Searching tags file..."
    set lines [grep "^$text'" $tagFile]
    if {[regexp {'(.*)'} $lines dummy fname]} {
        placeBookmark
        file::openQuietly $fname
        set inds [fortFindSub $text]
        #             set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
        display [lindex $inds 0]
        #             eval select $inds
        message "press <Ctl .> to return to original cursor position"
    }
    }
}

# Speedy search for a Fortran subroutine.  Performance is dramatically
# improved by scanning for the name alone first, rather than running
# complicated regexp search on the entire file.
#
proc fortFindSub {name} {
    set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
    set pos [minPos]
    while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
    set beg [lineStart [lindex $mtch 0]]
    set end [pos::math [nextLineStart [lindex $mtch 1]] -1]
    set line [getText $beg $end]
    if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
        return $mtch
    } else {
        set pos [lindex $mtch 1]
    }
    }
    error "Subroutine \"$name\" not found"
}

#=============================================================================
# Fortan auto-indentation
#
# Logic:
#    0.    Identify previous line
#            a) ignore comments and continuation lines
#            b) if current line is a CONTINUE that matches a DO, use the
#                first corresponding DO as the previous line
#
#    1.    Find leading whitespace for previous line
#
#    2.    Increase whitespace if previous line starts a block, i.e.,
#            a) DO loop
#            b) IF ... THEN
#            c) ELSE
#
#    3.    Decrease whitespace if current line ends a block, i.e.,
#            a) ELSE || ENDIF || END IF || ENDDO || END DO
#            b) <linenum> CONTINUE matching a preceding DO
#
#        or if previous line ends a DO loop on an executable statement, i.e.,
#            c) <linenum> (not CONTINUE) matching a preceding DO
#
####################################################################################
# Fortan auto-indentation
#
proc Fort::indentLine {} {
    set bol [lineStart [getPos]]
    set eol [pos::math [nextLineStart $bol] - 1]
    Fortindent $bol $eol
}

proc Fort::indentRegion {} {
    Fortindent [getPos] [selEnd]
}

####################################################################################
# Fortan auto-indentation of a specified region
#
proc Fortindent {pos0 pos1} {
    global fortDooz fortPrevLine fortTop msg
    global FortmodeVars

    set tag [quote::Regfind $FortmodeVars(markTag)]
    set doComment $FortmodeVars(indentComment)

    # Define regexps
    set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
    set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
    set mtPat {^[ \t]*$}
    set tab "    "

    set contPat {^     ([^ \t\n\r])[^\r\n]*$}
    set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
    set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set tailPat {[^\r\n]*$}

    set bobPat {^(if[^\n\r]*then|else|do)}
    set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
    set enddoPat {^(end[ \t]*do|continue)}

    #     set fortTop [fortSubTop $pos0]
    set fortTop -1

    catch {unset fortDooz}
    set fortPrevLine ""

    # Loop over region line by line
    set from [lindex [posToRowCol $pos0] 0]
    set to [lindex [posToRowCol $pos1] 0]

    while {$from <= $to} {
    set msg "Indenting line $from"
    message $msg
    set bol [lineStart [rowColToPos $from 0]]
    set eol [pos::math [nextLineStart $bol] - 1]
    set thisLine [getText $bol $eol]
    goto $bol

    # Check whether we're entering a new routine
    #
    if {[regexp $subPat $thisLine allofit subType subName]} {
        # alertnote "entering subr: \/$subName\/"
        set fortTop $bol
        catch {unset fortDooz}
    }

    # Is the current line a comment line...
    #
    if {[regexp $comPat $thisLine allofit cc tag pre body]} {
        if {$FortmodeVars(indentComment) > 0} {
        set body [string trimright $body]
        # alertnote "comment line: \/$pre\/$body\/"
        set lwhite "$cc     "

        replaceText $bol $eol $lwhite$body
        }

        # ... or a line of code (possibly empty)?
        #
    } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
        set body [string trimright $body]
        # alertnote "line: \/$pre\/$lnum\/$post\/$body\/"

        # is it a continuation line?
        #
        if {(![regexp "\t" $pre]) && ([string length $pre] == 5)} {
        set cont [string index $lnum$post$body 0]
        set body [string trimleft [string range $lnum$post$body 1 end]]
        } else {
        set cont {}
        }
        # alertnote "cont: \/$cont\/"

        # get whitespace for preceding line
        set enddo [getFortPrev $bol $lnum]
        set lwhite [getFortLwhite $bol]

        # if this line ends a block, decrease the whitespace
        if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
        set lwlen [expr [string length $lwhite] - 4]
        set lwhite [string range $lwhite 0 $lwlen]
        }

        if {[string length $lnum]} {
        if {[string index $lwhite 0] != $tab} {
            set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
        }
        set lnum " $lnum"
        }
        # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
        # message "$msg : replacing text      "

        if {[string length $cont]} {
        replaceText $bol $eol "     $cont$lwhite$body"
        } else {
        replaceText $bol $eol $lnum$lwhite$body
        if {[string length $body] > 0} {
            set fortPrevLine $lnum$lwhite$body
        }
        }
    } else {
        # message "$msg : Couldn't parse line         "
    }

    # message "$msg : Done                "
    incr from
    }
}

proc getFortLwhite {bol} {
    global fortDooz fortPrevLine fortTop msg
    # Define regexps
    set tab "    "
    set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set bobPat {^(if[^\n\r]*then|else|do)}
    set enddoPat {^(end[ \t]*do|continue)}

    if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
    # alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"

    if {[string length $lnum0]} {
        if {[string index $post0 0] == $tab} {
        set lwhite $post0
        } else {
        regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
        }
    } else {
        set lwhite $pre0
    }
    # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
    # message "$msg : got lwhite (initial)"

    # if there's a line number and it's not a CONTINUE or ENDDO,
    # then check for a matching DO statement and adjust
    # indentation if found
    #
    if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
        if {[getFortPrev [lineStart [pos::math $bol - 1]] $lnum0]} {
        set lwlen [expr [string length $lwhite] - 4]
        set lwhite [string range $lwhite 0 $lwlen]

        }
    }

    # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
    # then increase the whitespace
    #
    if {[regexp -nocase $bobPat $body0]} {
        set lwhite "$lwhite   "

        if {[regexp -nocase "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
        set eol [pos::math [nextLineStart $bol] - 1]
        set fortDooz($donum) [getText $bol $eol]
        }
    }
    # message "$msg : got lwhite (final)  "
    }
    return "$lwhite"
}

proc getFortPrev {bol lnum} {
    global fortDooz fortPrevLine fortTop msg
    # Define regexps
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
    set contPat {^     ([^ \t\n\r])[^\r\n]*$}

    # if there's a line number, check for a matching DO statement ...
    if {[string length $lnum]} {
    if {[lsearch [array names fortDooz] $lnum] >= 0} {
        set fortPrevLine $fortDooz($lnum)
        return 1
    } else {
        if {$fortTop < 0} {
        set fortTop [fortSubTop $bol]
        }
        if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
        set fortPrevLine [eval getText $dolst]
        set fortDooz($lnum) $fortPrevLine
        # alertnote "doLine0: \/$fortPrevLine\/"
        return 1
        }
    }
    }

    # ... otherwise find the first preceding non-comment, non-continuation line
    if {[string length $fortPrevLine] == 0} {
    if {[catch {
        set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
        set fortPrevLine [eval getText $lst]
        while {[regexp -nocase $contPat $fortPrevLine]} {
        set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
        set fortPrevLine [eval getText $lst]
        }
    }]} {
        # if search fails, we're at the top of a file, so reset indentation
        set fortPrevLine "      continue"
    }
    }

    # alertnote "prevLine: \/$fortPrevLine\/"
    # message "$msg : got prevLine"
    return 0
}

# Find the beginning of the current subroutine
#
proc fortSubTop {{pos 0}} {
    if {$pos == 0} {
    set pos [lineStart [getPos]]
    }
    set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}

    if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
    # set subLine [eval getText $sublst]
    # alertnote "subLine: \/$subLine\/"
    return [lindex $sublst 0]
    } else {
    return [minPos]
    }
}